home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / tbbyte.arc / FRACTION.PAS next >
Pascal/Delphi Source File  |  1985-08-16  |  3KB  |  108 lines
  1. {
  2.           Program to demonstrate use of function FRACTION.
  3.  
  4.   The algorithms used in the conversion from decimal to fraction were
  5.   adapted from the "PROGRAMMING INSIGHT" column in the May '85 issue
  6.   of BYTE magazine, p. 429.
  7.   The original was written in BASIC, by Dan Sandberg.
  8.   Converted to Turbo Pascal by Roy Collins, 5/5/85
  9.  
  10.   The constant PRECISION may be varied to customize to your needs -
  11.   do not set it higher than 36, or you will probably get "Arithmetic
  12.   Overflow" errors.
  13.  
  14.   Type "STR" must be defined for use in function FRACTION - it may be
  15.   a different size, but should be long enough to hold the longest fraction
  16.   you may generate.
  17.  
  18.   Following is the original BASIC code:
  19.     100 INPUT A:C=ABS(A):B=1
  20.     110 B=B/C:C=(1/C)-INT(1/C):IF C>.001 THEN 110
  21.     120 B=INT(B):PRINT A*B;"/";B:GOTO 100
  22.  
  23. }
  24.  
  25. program fraction;
  26. const
  27.   precision = 4;
  28. type
  29.   str = string[80];
  30. var
  31.   ch : char;
  32.   test_value, term, incr : real;
  33.  
  34. function fraction(test_value:real; precision:integer):str;
  35. var
  36.   quit : boolean;
  37.   b,c : real;
  38.   s1,s2 : str;
  39.   xprecision,
  40.   yprecision  : real;
  41. begin
  42.   xprecision := int(exp(precision*ln(10)));  {10**precision}
  43.   yprecision := exp(-precision*ln(10));      {10** -precision}
  44.   c := abs(test_value);
  45.   b := 1;
  46.   repeat
  47.     if b < xprecision then begin
  48.       b := b/c;
  49.       c := frac(1/c);
  50.       quit := c <= yprecision
  51.       end
  52.     else
  53.       quit := true;
  54.   until quit;
  55.   b := int(b);
  56.   test_value := int((test_value * b) + (yprecision/2));
  57.  
  58.   { Re-Format REAL to STRING, with no leading or trailing blanks }
  59.   str(test_value:12:0,s1);
  60.   while ((s1<>'') and (s1[1]=' ')) do
  61.     delete(s1,1,1);
  62.  
  63.   str(b:12:0,s2);
  64.   while ((s2<>'') and (s2[1]=' ')) do
  65.     delete(s2,1,1);
  66.  
  67.   { Remove extraneous trailing zeros }
  68.   while((s1[length(s1)]='0') and (s2[length(s2)]='0')) do begin
  69.     delete(s1,length(s1),1);
  70.     delete(s2,length(s2),1);
  71.     end;
  72.  
  73.   fraction := s1 + ' / ' + s2;
  74. end; (* func fraction *)
  75.  
  76. begin
  77.   write('Do you want to let the demo run itself? (Y/N) ');
  78.   repeat
  79.     read(kbd,ch);
  80.     ch := upcase(ch);
  81.   until ch in ['Y','N'];
  82.   writeln(ch);
  83.   if ch='N' then begin
  84.     writeln('To terminate, enter 0.0');
  85.     writeln;
  86.     repeat
  87.       test_value := 0.0;
  88.       write('Enter decimal: ');
  89.       readln(test_value);
  90.       if test_value <> 0 then
  91.         writeln('Fraction is ',fraction(test_value,precision));
  92.     until test_value = 0.0;
  93.     end
  94.   else begin { auto run }
  95.     write('Enter Initial Value: ');
  96.     readln(test_value);
  97.     write('Enter Increment: ');
  98.     readln(incr);
  99.     write('Enter Terminal Value');
  100.     readln(term);
  101.     writeln;
  102.     repeat
  103.       writeln(test_value:1:precision,' = ',fraction(test_value,precision));
  104.       test_value := test_value + incr;
  105.     until test_value>term;
  106.     end;
  107. end.
  108.